home *** CD-ROM | disk | FTP | other *** search
/ PC Open 107 / PC Open 107 CD 1.bin / CD1 / INTERNET / COPIA SITI / Getleft / getleft-setup-notcl.exe / {app} / scripts / tablelistBind.tcl < prev    next >
Encoding:
Text File  |  2004-01-03  |  28.1 KB  |  855 lines
  1. #==============================================================================
  2. # Contains private procedures used in tablelist bindings.
  3. #
  4. # Copyright (c) 2000-2004  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
  5. #==============================================================================
  6.  
  7. #
  8. # Binding tag Tablelist
  9. # =====================
  10. #
  11.  
  12. #------------------------------------------------------------------------------
  13. # tablelist::addActiveTag
  14. #
  15. # This procedure is invoked when the tablelist widget win gains the keyboard
  16. # focus.  It adds the "active" tag to the line that displays the active element
  17. # of the widget in its body text child.
  18. #------------------------------------------------------------------------------
  19. proc tablelist::addActiveTag win {
  20.     upvar ::tablelist::ns${win}::data data
  21.  
  22.     set line [expr {$data(activeIdx) + 1}]
  23.     $data(body) tag add active $line.0 $line.end
  24.  
  25.     set data(ownsFocus) 1
  26. }
  27.  
  28. #------------------------------------------------------------------------------
  29. # tablelist::removeActiveTag
  30. #
  31. # This procedure is invoked when the tablelist widget win loses the keyboard
  32. # focus.  It removes the "active" tag from the line that displays the active
  33. # element of the widget in its body text child.
  34. #------------------------------------------------------------------------------
  35. proc tablelist::removeActiveTag win {
  36.     upvar ::tablelist::ns${win}::data data
  37.  
  38.     set line [expr {$data(activeIdx) + 1}]
  39.     $data(body) tag remove active $line.0 $line.end
  40.  
  41.     set data(ownsFocus) 0
  42. }
  43.  
  44. #------------------------------------------------------------------------------
  45. # tablelist::cleanup
  46. #
  47. # This procedure is invoked when the tablelist widget win is destroyed.  It
  48. # executes some cleanup operations.
  49. #------------------------------------------------------------------------------
  50. proc tablelist::cleanup win {
  51.     upvar ::tablelist::ns${win}::data data
  52.  
  53.     #
  54.     # Cancel the execution of all delayed adjustSeps, makeStripes,
  55.     # stretchColumns, synchronize, and redisplay commands
  56.     #
  57.     foreach afterId {sepsId stripesId stretchId syncId redispId} {
  58.     if {[info exists data($afterId)]} {
  59.         after cancel $data($afterId)
  60.     }
  61.     }
  62.  
  63.     #
  64.     # If there is a list variable associated with the
  65.     # widget then remove the trace set on this variable
  66.     #
  67.     if {$data(hasListVar)} {
  68.     trace vdelete ::$data(-listvariable) wu $data(listVarTraceCmd)
  69.     }
  70.  
  71.     namespace delete ::tablelist::ns$win
  72.     catch {rename ::$win ""}
  73. }
  74.  
  75. #
  76. # Binding tag TablelistBody
  77. # =========================
  78. #
  79.  
  80. #------------------------------------------------------------------------------
  81. # tablelist::defineTablelistBody
  82. #
  83. # Defines the binding tag TablelistBody to have the same events as Listbox and
  84. # the binding scripts obtained from those of Listbox by replacing the widget %W
  85. # with its parent as well as the %x and %y fields with the corresponding
  86. # coordinates relative to the parent.
  87. #------------------------------------------------------------------------------
  88. proc tablelist::defineTablelistBody {} {
  89.     bind TablelistBody <Button-1> {
  90.     if {[winfo exists %W]} {
  91.         tablelist::condEditContainingCell %W %x %y
  92.     }
  93.     }
  94.  
  95.     bind TablelistBody <ButtonRelease-1> {
  96.     if {[winfo exists %W]} {
  97.         tablelist::condEvalInvokeCmd %W %X %Y
  98.     }
  99.     }
  100.  
  101.     foreach event [bind Listbox] {
  102.     set script [strMap {
  103.         %W $tablelist::W  %x $tablelist::x  %y $tablelist::y
  104.         tkListboxAutoScan   tablelist::tablelistAutoScan
  105.         tk::ListboxAutoScan tablelist::tablelistAutoScan
  106.     } [bind Listbox $event]]
  107.  
  108.     bind TablelistBody $event +[format {
  109.         if {[winfo exists %%W]} {
  110.         set tablelist::W [winfo parent %%W]
  111.         set tablelist::x [expr {%%x + [winfo x %%W]}]
  112.         set tablelist::y [expr {%%y + [winfo y %%W]}]
  113.         %s
  114.         }
  115.     } $script]
  116.     }
  117. }
  118.  
  119. #------------------------------------------------------------------------------
  120. # tablelist::tablelistAutoScan
  121. #
  122. # This is a modified version of the Tk library procedure tk(::)ListboxAutoScan.
  123. # It is invoked when the mouse leaves the body text child of a tablelist
  124. # widget.  It scrolls the child and reschedules itself as an after command so
  125. # that the child continues to scroll until the mouse moves back into the window
  126. # or the mouse button is released.
  127. #------------------------------------------------------------------------------
  128. proc tablelist::tablelistAutoScan win {
  129.     if {![winfo exists $win] || [string compare [::$win editwinpath] ""] != 0} {
  130.     return ""
  131.     }
  132.  
  133.     if {[array exists ::tk::Priv]} {
  134.     set x $::tk::Priv(x)
  135.     set y $::tk::Priv(y)
  136.     } else {
  137.     set x $::tkPriv(x)
  138.     set y $::tkPriv(y)
  139.     }
  140.  
  141.     set w [::$win bodypath]
  142.     set _x [expr {$x - [winfo x $w]}]
  143.     set _y [expr {$y - [winfo y $w]}]
  144.  
  145.     if {$_y >= [winfo height $w]} {
  146.     yviewSubCmd $win {scroll 1 units}
  147.     } elseif {$_y < 0} {
  148.     yviewSubCmd $win {scroll -1 units}
  149.     } elseif {$_x >= [winfo width $w]} {
  150.     xviewSubCmd $win {scroll 2 units}
  151.     } elseif {$_x < 0} {
  152.     xviewSubCmd $win {scroll -2 units}
  153.     } else {
  154.     return ""
  155.     }
  156.  
  157.     if {[array exists ::tk::Priv]} {
  158.     tk::ListboxMotion $win [rowIndex $win @$x,$y 1]
  159.     set ::tk::Priv(afterId) \
  160.         [after 50 [list tablelist::tablelistAutoScan $win]]
  161.     } else {
  162.     tkListboxMotion $win [rowIndex $win @$x,$y 1]
  163.     set ::tkPriv(afterId) \
  164.         [after 50 [list tablelist::tablelistAutoScan $win]]
  165.     }
  166. }
  167.  
  168. #------------------------------------------------------------------------------
  169. # tablelist::condEditContainingCell
  170. #
  171. # This procedure is invoked when mouse button 1 is pressed in the body w of a
  172. # tablelist widget or in one of its separator frames.  If the mouse click
  173. # occurred inside an editable cell and the latter is not already being edited,
  174. # then the procedure starts the interactive editing in that cell.  Otherwise it
  175. # finishes a possibly active cell editing.
  176. #------------------------------------------------------------------------------
  177. proc tablelist::condEditContainingCell {w x y} {
  178.     set win [winfo parent $w]
  179.     upvar ::tablelist::ns${win}::data data
  180.     synchronize $win
  181.  
  182.     #
  183.     # Get the containing cell from the coordinates relative to the parent
  184.     #
  185.     incr x [winfo x $w]
  186.     incr y [winfo y $w]
  187.     set row [containingSubCmd $win $y]
  188.     set col [containingcolumnSubCmd $win $x]
  189.  
  190.     if {$row >= 0 && $col >= 0 && [isCellEditable $win $row $col]} {
  191.     #
  192.     # Get the coordinates relative to the
  193.     # tablelist body and invoke editcellSubCmd
  194.     #
  195.     set w $data(body)
  196.     incr x -[winfo x $w]
  197.     incr y -[winfo y $w]
  198.     scan [$w index @$x,$y] %d.%d line charPos
  199.     editcellSubCmd $win $row $col 0 $charPos
  200.     } else {
  201.     #
  202.     # Finish a possibly active cell editing
  203.     #
  204.     if {$data(editRow) >= 0} {
  205.         finisheditingSubCmd $win
  206.     }
  207.     }
  208. }
  209.  
  210. #------------------------------------------------------------------------------
  211. # tablelist::condEvalInvokeCmd
  212. #
  213. # This procedure is invoked when mouse button 1 is released in the body w of a
  214. # tablelist widget or in one of its separator frames.  If interactive cell
  215. # editing is in progress in a column whose associated edit window has an invoke
  216. # command that hasn't yet been called in the current edit session, then the
  217. # procedure evaluates that command.
  218. #------------------------------------------------------------------------------
  219. proc tablelist::condEvalInvokeCmd {w X Y} {
  220.     set win [winfo parent $w]
  221.     upvar ::tablelist::ns${win}::data data
  222.  
  223.     if {$data(editCol) < 0} {
  224.     return ""
  225.     }
  226.  
  227.     variable editWin
  228.     set name $data($data(editCol)-editwindow)
  229.     if {[string compare $editWin($name-invokeCmd) ""] == 0 || $data(invoked)} {
  230.     return ""
  231.     }
  232.  
  233.     #
  234.     # If the edit window is a checkbutton then ignore this event outside the
  235.     # edit window or if the checkbutton's selection state has already been
  236.     # toggled (the latter is the case if the windowing system equals "x11")
  237.     #
  238.     if {[string compare [winfo class $data(bodyFrEd)] Checkbutton] == 0} {
  239.     set c [winfo containing -displayof $w $X $Y]
  240.     if {[string compare $c $data(bodyFrEd)] != 0 ||
  241.         [string compare $data(editText) $data(origEditText)] != 0} {
  242.         return ""
  243.     }
  244.     }
  245.  
  246.     eval [strMap {%W $data(bodyFrEd)} $editWin($name-invokeCmd)]
  247.     set data(invoked) 1
  248. }
  249.  
  250. #
  251. # Binding tags TablelistLabel, TablelistSubLabel, and TablelistArrow
  252. # ==================================================================
  253. #
  254.  
  255. #------------------------------------------------------------------------------
  256. # tablelist::defineTablelistSubLabel
  257. #
  258. # Defines the binding tag TablelistSubLabel (for children of tablelist labels)
  259. # to have the same events as TablelistLabel and the binding scripts obtained
  260. # from those of TablelistLabel by replacing the widget %W with its parent as
  261. # well as the %x and %y fields with the corresponding coordinates relative to
  262. # the parent.
  263. #------------------------------------------------------------------------------
  264. proc tablelist::defineTablelistSubLabel {} {
  265.     foreach event [bind TablelistLabel] {
  266.     set script [strMap {
  267.         %W $tablelist::W  %x $tablelist::x  %y $tablelist::y
  268.     } [bind TablelistLabel $event]]
  269.  
  270.     bind TablelistSubLabel $event [format {
  271.         set tablelist::W [winfo parent %%W]
  272.         set tablelist::x [expr {%%x + [winfo x %%W]}]
  273.         set tablelist::y [expr {%%y + [winfo y %%W]}]
  274.         %s
  275.     } $script]
  276.     }
  277. }
  278.  
  279. #------------------------------------------------------------------------------
  280. # tablelist::defineTablelistArrow
  281. #
  282. # Defines the binding tag TablelistArrow to have the same events as
  283. # TablelistLabel and the binding scripts obtained from those of TablelistLabel
  284. # by replacing the widget %W with the containing label as well as the %x and %y
  285. # fields with the corresponding coordinates relative to the label
  286. #------------------------------------------------------------------------------
  287. proc tablelist::defineTablelistArrow {} {
  288.     foreach event [bind TablelistLabel] {
  289.     set script [strMap {
  290.         %W $tablelist::W  %x $tablelist::x  %y $tablelist::y
  291.     } [bind TablelistLabel $event]]
  292.  
  293.     bind TablelistArrow $event [format {
  294.         if {$::tk_version < 8.4} {
  295.         regexp {^.+ -in (.+)$} [place info %%W] \
  296.                tablelist::dummy tablelist::W
  297.         } else {
  298.         set tablelist::W [lindex [place configure %%W -in] end]
  299.         }
  300.         set tablelist::x \
  301.         [expr {%%x + [winfo x %%W] - [winfo x $tablelist::W]}]
  302.         set tablelist::y \
  303.         [expr {%%y + [winfo y %%W] - [winfo y $tablelist::W]}]
  304.         %s
  305.     } $script]
  306.     }
  307. }
  308.  
  309. #------------------------------------------------------------------------------
  310. # tablelist::labelEnter
  311. #
  312. # This procedure is invoked when the mouse pointer enters the header label w of
  313. # a tablelist widget, or is moving within that label.  It updates the cursor,
  314. # depending on whether the pointer is on the right border of the label or not.
  315. #------------------------------------------------------------------------------
  316. proc tablelist::labelEnter {w x} {
  317.     parseLabelPath $w win col
  318.     upvar ::tablelist::ns${win}::data data
  319.  
  320.     configLabel $w -cursor $data(-cursor)
  321.     if {$data(isDisabled)} {
  322.     return ""
  323.     }
  324.  
  325.     if {$data(-resizablecolumns) && $data($col-resizable) &&
  326.     $x >= [winfo width $w] - [$w cget -borderwidth] - 4} {
  327.     configLabel $w -cursor $data(-resizecursor)
  328.     }
  329. }
  330.  
  331. #------------------------------------------------------------------------------
  332. # tablelist::labelB1Down
  333. #
  334. # This procedure is invoked when mouse button 1 is pressed in the header label
  335. # w of a tablelist widget.  If the pointer is on the right border of the label
  336. # then the procedure records its x-coordinate relative to the label, the width
  337. # of the column, and some other data needed later.  Otherwise it saves the
  338. # label's relief so it can be restored later, and changes the relief to sunken.
  339. #------------------------------------------------------------------------------
  340. proc tablelist::labelB1Down {w x} {
  341.     parseLabelPath $w win col
  342.     upvar ::tablelist::ns${win}::data data
  343.  
  344.     if {$data(isDisabled) ||
  345.     [info exists data(x)]} {        ;# resize operation in progress
  346.     return ""
  347.     }
  348.  
  349.     set data(labelClicked) 1
  350.     set labelWidth [winfo width $w]
  351.  
  352.     if {$data(-resizablecolumns) && $data($col-resizable) &&
  353.     $x >= $labelWidth - [$w cget -borderwidth] - 4} {
  354.     set data(x) $x
  355.  
  356.     set data(oldStretchedColWidth) [expr {$labelWidth - 2*$data(charWidth)}]
  357.     set data(oldColDelta) $data($col-delta)
  358.     set data(configColWidth) [lindex $data(-columns) [expr {3*$col}]]
  359.  
  360.     if {$col == $data(arrowCol)} {
  361.         set data(minColWidth) $data(arrowWidth)
  362.     } else {
  363.         set data(minColWidth) 1
  364.     }
  365.  
  366.     set topWin [winfo toplevel $win]
  367.     set data(topBindEsc) [bind $topWin <Escape>]
  368.     bind $topWin <Escape> [list tablelist::escape [strMap {% %%} $win] $col]
  369.     } else {
  370.     set data(inClickedLabel) 1
  371.     set data(relief) [$w cget -relief]
  372.  
  373.     if {[info exists data($col-labelcommand)] ||
  374.         [string compare $data(-labelcommand) ""] != 0} {
  375.         set data(changeRelief) 1
  376.         configLabel $w -relief sunken
  377.     } else {
  378.         set data(changeRelief) 0
  379.     }
  380.  
  381.     if {$data(-movablecolumns)} {
  382.         set topWin [winfo toplevel $win]
  383.         set data(topBindEsc) [bind $topWin <Escape>]
  384.         bind $topWin <Escape> \
  385.          [list tablelist::escape [strMap {% %%} $win] $col]
  386.     }
  387.     }
  388. }
  389.  
  390. #------------------------------------------------------------------------------
  391. # tablelist::labelB1Motion
  392. #
  393. # This procedure is invoked to process mouse motion events in the header label
  394. # w of a tablelist widget while button 1 is down.  If this event occured during
  395. # a column resize operation then the procedure computes the difference between
  396. # the pointer's new x-coordinate relative to that label and the one recorded by
  397. # the last invocation of labelB1Down, and adjusts the width of the
  398. # corresponding column accordingly.  Otherwise a horizontal scrolling is
  399. # performed if needed, and the would-be target position of the clicked label is
  400. # visualized if the columns are movable.
  401. #------------------------------------------------------------------------------
  402. proc tablelist::labelB1Motion {w x y} {
  403.     parseLabelPath $w win col
  404.     upvar ::tablelist::ns${win}::data data
  405.  
  406.     if {!$data(labelClicked)} {
  407.     return ""
  408.     }
  409.  
  410.     if {[info exists data(x)]} {        ;# resize operation in progress
  411.     set width [expr {$data(oldStretchedColWidth) + $x - $data(x)}]
  412.     if {$width >= $data(minColWidth)} {
  413.         set idx [expr {3*$col}]
  414.         set data(-columns) [lreplace $data(-columns) $idx $idx -$width]
  415.         set idx [expr {2*$col}]
  416.         set data(colList) [lreplace $data(colList) $idx $idx $width]
  417.         set data($col-lastStaticWidth) $width
  418.         set data($col-delta) 0
  419.         adjustColumns $win {} 0
  420.         redisplayCol $win $col [rowIndex $win @0,0 0] \
  421.                    [rowIndex $win @0,[winfo height $win] 0]
  422.     }
  423.     } else {
  424.     #
  425.     # Scroll the window horizontally if needed
  426.     #
  427.     set scroll 0
  428.     set X [expr {[winfo rootx $w] + $x}]
  429.     set hdrX [winfo rootx $data(hdr)]
  430.     set rightX [expr {$hdrX + [winfo width $data(hdr)]}]
  431.     if {($X >= $rightX) &&
  432.         (![info exists data(X)] || $data(X) < $rightX)} {
  433.         set scroll 1
  434.     } elseif {($X < $hdrX) &&
  435.           (![info exists data(X)] || $data(X) >= $hdrX)} {
  436.         set scroll 1
  437.     }
  438.     set data(X) $X
  439.     if ($scroll) {
  440.         horizAutoScan $win
  441.     }
  442.  
  443.     if {$x >= 0 && $x < [winfo width $w] &&
  444.         $y >= 0 && $y < [winfo height $w]} {
  445.         #
  446.         # The following code is needed because the event can also
  447.         # occur in the canvas displaying an up- or down-arrow
  448.         #
  449.         set data(inClickedLabel) 1
  450.         $data(hdrTxtFrCanv) configure -cursor $data(-cursor)
  451.         configLabel $w -cursor $data(-cursor)
  452.         if {$data(changeRelief)} {
  453.         configLabel $w -relief sunken
  454.         }
  455.  
  456.         place forget $data(hdrGap)
  457.     } else {
  458.         #
  459.         # The following code is needed because the event can also
  460.         # occur in the canvas displaying an up- or down-arrow
  461.         #
  462.         set data(inClickedLabel) 0
  463.         configLabel $w -relief $data(relief)
  464.  
  465.         if {$data(-movablecolumns)} {
  466.         $data(hdrTxtFrCanv) configure -cursor $data(-movecolumncursor)
  467.         configLabel $w -cursor $data(-movecolumncursor)
  468.  
  469.         #
  470.         # Get the target column index and visualize the
  471.         # would-be target position of the clicked label
  472.         #
  473.         set contW [winfo containing -displayof $w $X [winfo rooty $w]]
  474.         parseLabelPath $contW dummy targetCol
  475.         if {[info exists targetCol]} {
  476.             set master $contW
  477.             if {$X < [winfo rootx $contW] + [winfo width $contW]/2} {
  478.             set relx 0.0
  479.             } else {
  480.             incr targetCol
  481.             set relx 1.0
  482.             }
  483.         } elseif {[string compare $contW $data(hdrGap)] == 0} {
  484.             set targetCol $data(targetCol)
  485.             set master $data(master)
  486.             set relx $data(relx)
  487.         } elseif {$X < [winfo rootx $w]} {
  488.             for {set targetCol 0} {$targetCol < $data(colCount)} \
  489.             {incr targetCol} {
  490.             if {!$data($targetCol-hide)} {
  491.                 break
  492.             }
  493.             }
  494.             set master $data(hdrTxtFr)
  495.             set relx 0.0
  496.         } else {
  497.             for {set targetCol $data(lastCol)} {$targetCol >= 0} \
  498.             {incr targetCol -1} {
  499.             if {!$data($targetCol-hide)} {
  500.                 break
  501.             }
  502.             }
  503.             incr targetCol
  504.             set master $data(hdrTxtFr)
  505.             set relx 1.0
  506.         }
  507.         set data(targetCol) $targetCol
  508.         set data(master) $master
  509.         set data(relx) $relx
  510.         $data(hdrTxtFrCanv) configure -cursor $data(-movecolumncursor)
  511.         configLabel $w -cursor $data(-movecolumncursor)
  512.         place $data(hdrGap) -in $master -anchor n -bordermode outside \
  513.                     -relheight 1.0 -relx $relx
  514.         }
  515.     }
  516.     }
  517. }
  518.  
  519. #------------------------------------------------------------------------------
  520. # tablelist::labelB1Enter
  521. #
  522. # This procedure is invoked when the mouse pointer enters the header label w of
  523. # a tablelist widget while mouse button 1 is down.  If the label was not
  524. # previously clicked then nothing happens.  Otherwise, if this event occured
  525. # during a column resize operation then the procedure updates the mouse cursor
  526. # accordingly.  Otherwise it changes the label's relief to sunken.
  527. #------------------------------------------------------------------------------
  528. proc tablelist::labelB1Enter w {
  529.     parseLabelPath $w win col
  530.     upvar ::tablelist::ns${win}::data data
  531.  
  532.     if {!$data(labelClicked)} {
  533.     return ""
  534.     }
  535.  
  536.     configLabel $w -cursor $data(-cursor)
  537.  
  538.     if {[info exists data(x)]} {        ;# resize operation in progress
  539.     configLabel $w -cursor $data(-resizecursor)
  540.     } else {
  541.     set data(inClickedLabel) 1
  542.     if {$data(changeRelief)} {
  543.         configLabel $w -relief sunken
  544.     }
  545.     }
  546. }
  547.  
  548. #------------------------------------------------------------------------------
  549. # tablelist::labelB1Leave
  550. #
  551. # This procedure is invoked when the mouse pointer leaves the header label w of
  552. # a tablelist widget while mouse button 1 is down.  If the label was not
  553. # previously clicked then nothing happens.  Otherwise, if no column resize
  554. # operation is in progress then the procedure restores the label's relief, and,
  555. # if the columns are movable, then it changes the mouse cursor, too.
  556. #------------------------------------------------------------------------------
  557. proc tablelist::labelB1Leave {w x y} {
  558.     parseLabelPath $w win col
  559.     upvar ::tablelist::ns${win}::data data
  560.  
  561.     if {!$data(labelClicked) ||
  562.     [info exists data(x)]} {        ;# resize operation in progress
  563.     return ""
  564.     }
  565.  
  566.     #
  567.     # The following code is needed because the event can also
  568.     # occur in the canvas displaying an up- or down-arrow
  569.     #
  570.     if {$x >= 0 && $x < [winfo width $w] &&
  571.     $y >= 0 && $y < [winfo height $w]} {
  572.     return ""
  573.     }
  574.  
  575.     set data(inClickedLabel) 0
  576.     configLabel $w -relief $data(relief)
  577. }
  578.  
  579. #------------------------------------------------------------------------------
  580. # tablelist::labelB1Up
  581. #
  582. # This procedure is invoked when mouse button 1 is released, if it was
  583. # previously clicked in a label of the tablelist widget win.  If this event
  584. # occured during a column resize operation then the procedure redisplays the
  585. # columns and stretches the stretchable ones.  Otherwise, if the mouse button
  586. # was released in the previously clicked label then the procedure restores the
  587. # label's relief and invokes the command specified with the -labelcommand
  588. # configuration option, passing to it the widget name and the column number as
  589. # arguments.  Otherwise the column of the previously clicked label is moved
  590. # before the column containing the mouse cursor or to its right, if the columns
  591. # are movable.
  592. #------------------------------------------------------------------------------
  593. proc tablelist::labelB1Up {w X} {
  594.     parseLabelPath $w win col
  595.     upvar ::tablelist::ns${win}::data data
  596.  
  597.     if {!$data(labelClicked)} {
  598.     return ""
  599.     }
  600.  
  601.     if {[info exists data(x)]} {        ;# resize operation in progress
  602.     configLabel $w -cursor $data(-cursor)
  603.     bind [winfo toplevel $win] <Escape> $data(topBindEsc)
  604.     redisplayWhenIdle $win
  605.     if {$data(-width) <= 0} {
  606.         $data(hdr) configure -width $data(hdrPixels)
  607.     } elseif {[info exists data(stretchableCols)] &&
  608.           [lsearch -exact $data(stretchableCols) $col] >= 0} {
  609.         set oldColWidth \
  610.         [expr {$data(oldStretchedColWidth) - $data(oldColDelta)}]
  611.         set stretchedColWidth \
  612.         [expr {[winfo width $w] - 2*$data(charWidth)}]
  613.         if {$oldColWidth < $data(stretchablePixels) &&
  614.         $stretchedColWidth < $oldColWidth + $data(delta)} {
  615.         #
  616.         # Compute the new column width, using the following equations:
  617.         #
  618.         # $stretchedColWidth = $colWidth + $colDelta
  619.         # $colDelta =
  620.         #    ($data(delta) - $colWidth + $oldColWidth) * $colWidth /
  621.         #    ($data(stretchablePixels) + $colWidth - $oldColWidth)
  622.         #
  623.         set colWidth [expr {
  624.             $stretchedColWidth *
  625.             ($data(stretchablePixels) - $oldColWidth) /
  626.             ($data(stretchablePixels) + $data(delta) -
  627.              $stretchedColWidth)
  628.         }]
  629.         if {$colWidth < 1} {
  630.             set colWidth 1
  631.         }
  632.         set idx [expr {3*$col}]
  633.         set data(-columns) \
  634.             [lreplace $data(-columns) $idx $idx -$colWidth]
  635.         set idx [expr {2*$col}]
  636.         set data(colList) [lreplace $data(colList) $idx $idx $colWidth]
  637.         set data($col-delta) [expr {$stretchedColWidth - $colWidth}]
  638.         }
  639.     }
  640.     stretchColumns $win $col
  641.     unset data(x)
  642.     } else {
  643.     if {[info exists data(X)]} {
  644.         unset data(X)
  645.     }
  646.         if {$data(-movablecolumns)} {
  647.         bind [winfo toplevel $win] <Escape> $data(topBindEsc)
  648.         place forget $data(hdrGap)
  649.     }
  650.     if {$data(inClickedLabel)} {
  651.         configLabel $w -relief $data(relief)
  652.         if {[info exists data($col-labelcommand)]} {
  653.         uplevel #0 $data($col-labelcommand) [list $win $col]
  654.         } elseif {[string compare $data(-labelcommand) ""] != 0} {
  655.         uplevel #0 $data(-labelcommand) [list $win $col]
  656.         }
  657.     } elseif {$data(-movablecolumns)} {
  658.         $data(hdrTxtFrCanv) configure -cursor $data(-cursor)
  659.         if {$data(targetCol) != $col && $data(targetCol) != $col + 1} {
  660.         movecolumnSubCmd $win $col $data(targetCol)
  661.         }
  662.     }
  663.     }
  664.  
  665.     set data(labelClicked) 0
  666. }
  667.  
  668. #------------------------------------------------------------------------------
  669. # tablelist::labelB3Down
  670. #
  671. # This procedure is invoked when mouse button 3 is pressed in the header label
  672. # w of a tablelist widget.  It configures the width of the given column to be
  673. # just large enough to hold all the elements (including the label).
  674. #------------------------------------------------------------------------------
  675. proc tablelist::labelB3Down w {
  676.     parseLabelPath $w win col
  677.     upvar ::tablelist::ns${win}::data data
  678.  
  679.     if {!$data(isDisabled) &&
  680.     $data(-resizablecolumns) && $data($col-resizable)} {
  681.     doColConfig $col $win -width 0
  682.     }
  683. }
  684.  
  685. #------------------------------------------------------------------------------
  686. # tablelist::labelShiftB3Down
  687. #
  688. # This procedure is invoked when mouse button 3 together with the Shift key is
  689. # pressed in the header label w of a tablelist widget.  It restores the last
  690. # static width of the given column.
  691. #------------------------------------------------------------------------------
  692. proc tablelist::labelShiftB3Down w {
  693.     parseLabelPath $w win col
  694.     upvar ::tablelist::ns${win}::data data
  695.  
  696.     if {!$data(isDisabled) &&
  697.     $data(-resizablecolumns) && $data($col-resizable)} {
  698.     doColConfig $col $win -width -$data($col-lastStaticWidth)
  699.     }
  700. }
  701.  
  702. #------------------------------------------------------------------------------
  703. # tablelist::escape
  704. #
  705. # This procedure is invoked to process <Escape> events in the top-level window
  706. # containing the tablelist widget win during a column resize or move operation.
  707. # The procedure cancels the action in progress and, in case of column resizing,
  708. # it restores the initial width of the respective column.
  709. #------------------------------------------------------------------------------
  710. proc tablelist::escape {win col} {
  711.     upvar ::tablelist::ns${win}::data data
  712.  
  713.     set w $data(hdrTxtFrLbl)$col
  714.     if {[info exists data(x)]} {        ;# resize operation in progress
  715.     configLabel $w -cursor $data(-cursor)
  716.     update idletasks
  717.     bind [winfo toplevel $win] <Escape> $data(topBindEsc)
  718.     set idx [expr {3*$col}]
  719.     setupColumns $win [lreplace $data(-columns) $idx $idx \
  720.                     $data(configColWidth)] 0
  721.     adjustColumns $win $col 1
  722.     redisplayCol $win $col [rowIndex $win @0,0 0] \
  723.                    [rowIndex $win @0,[winfo height $win] 0]
  724.     unset data(x)
  725.     set data(labelClicked) 0
  726.     } elseif {!$data(inClickedLabel)} {
  727.     configLabel $w -cursor $data(-cursor)
  728.     $data(hdrTxtFrCanv) configure -cursor $data(-cursor)
  729.     bind [winfo toplevel $win] <Escape> $data(topBindEsc)
  730.     place forget $data(hdrGap)
  731.     if {[info exists data(X)]} {
  732.         unset data(X)
  733.     }
  734.     set data(labelClicked) 0
  735.     }
  736. }
  737.  
  738. #------------------------------------------------------------------------------
  739. # tablelist::parseLabelPath
  740. #
  741. # Extracts the path name of the tablelist widget as well as the column number
  742. # from the path name w of a header label.
  743. #------------------------------------------------------------------------------
  744. proc tablelist::parseLabelPath {w winName colName} {
  745.     upvar $winName win $colName col
  746.  
  747.     regexp {^(.+)\.hdr\.t\.f\.l([0-9]+)$} $w dummy win col
  748. }
  749.  
  750. #------------------------------------------------------------------------------
  751. # tablelist::redisplayCol
  752. #
  753. # Redisplays the elements of the col'th column of the tablelist widget win, in
  754. # the range specified by first and last.
  755. #------------------------------------------------------------------------------
  756. proc tablelist::redisplayCol {win col first last} {
  757.     upvar ::tablelist::ns${win}::data data
  758.  
  759.     if {$data($col-hide) || $first < 0} {
  760.     return ""
  761.     }
  762.  
  763.     set snipStr $data(-snipstring)
  764.     set fmtCmdFlag [info exists data($col-formatcommand)]
  765.     set colFont [lindex $data(colFontList) $col]
  766.  
  767.     set w $data(body)
  768.     set pixels [lindex $data(colList) [expr {2*$col}]]
  769.     if {$pixels == 0} {                ;# convention: dynamic width
  770.     if {$data($col-maxPixels) > 0 &&
  771.         $data($col-reqPixels) > $data($col-maxPixels)} {
  772.         set pixels $data($col-maxPixels)
  773.     }
  774.     }
  775.     if {$pixels != 0} {
  776.     incr pixels $data($col-delta)
  777.     }
  778.     set alignment [lindex $data(colList) [expr {2*$col + 1}]]
  779.  
  780.     for {set idx $first; set line [expr {$first + 1}]} {$idx <= $last} \
  781.     {incr idx; incr line} {
  782.     if {$idx == $data(editRow) && $col == $data(editCol)} {
  783.         continue
  784.     }
  785.  
  786.     #
  787.     # Adjust the cell text and the image width
  788.     #
  789.     set item [lindex $data(itemList) $idx]
  790.     set text [lindex $item $col]
  791.     if {$fmtCmdFlag} {
  792.         set text [uplevel #0 $data($col-formatcommand) [list $text]]
  793.     }
  794.     set text [strToDispStr $text]
  795.     set key [lindex $item end]
  796.     if {[info exists data($key-$col-image)]} {
  797.         set image $data($key-$col-image)
  798.         set imageWidth [image width $image]
  799.     } else {
  800.         set image ""
  801.         set imageWidth 0
  802.     }
  803.     if {[info exists data($key-$col-font)]} {
  804.         set cellFont $data($key-$col-font)
  805.     } elseif {[info exists data($key-font)]} {
  806.         set cellFont $data($key-font)
  807.     } else {
  808.         set cellFont $colFont
  809.     }
  810.     adjustElem $win text imageWidth $cellFont \
  811.            $pixels $alignment $snipStr
  812.  
  813.     #
  814.     # Delete the old cell contents between the
  815.     # two tabs, and insert the text and the image
  816.     #
  817.     findCellTabs $win $line $col tabIdx1 tabIdx2
  818.     $w delete $tabIdx1+1c $tabIdx2
  819.     insertElem $w $tabIdx1+1c $text $image $imageWidth $alignment
  820.     }
  821. }
  822.  
  823. #------------------------------------------------------------------------------
  824. # tablelist::horizAutoScan
  825. #
  826. # This procedure is invoked when the mouse leaves the header frame of a
  827. # tablelist widget.  It scrolls the child and reschedules itself as an after
  828. # command so that the child continues to scroll until the mouse moves back into
  829. # the window or the mouse button is released.
  830. #------------------------------------------------------------------------------
  831. proc tablelist::horizAutoScan win {
  832.     if {![winfo exists $win]} {
  833.     return ""
  834.     }
  835.  
  836.     upvar ::tablelist::ns${win}::data data
  837.     if {![info exists data(X)]} {
  838.     return ""
  839.     }
  840.  
  841.     set X $data(X)
  842.     set hdrX [winfo rootx $data(hdr)]
  843.     set rightX [expr {$hdrX + [winfo width $data(hdr)]}]
  844.  
  845.     if {$X >= $rightX} {
  846.     xviewSubCmd $win {scroll 2 units}
  847.     } elseif {$X < $hdrX} {
  848.     xviewSubCmd $win {scroll -2 units}
  849.     } else {
  850.     return ""
  851.     }
  852.  
  853.     after 50 [list tablelist::horizAutoScan $win]
  854. }
  855.